VERSION 5.00 Begin VB.Form frmTrans Appearance = 0 'Flat BackColor = &H00C0C0C0& Caption = "Trans" ClientHeight = 6225 ClientLeft = 690 ClientTop = 615 ClientWidth = 7830 BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H80000008& KeyPreview = -1 'True LinkTopic = "Form1" PaletteMode = 1 'UseZOrder ScaleHeight = 415 ScaleMode = 3 'Pixel ScaleWidth = 522 Begin VB.CheckBox chkHideSurfaces Caption = "Hide Surfaces" Height = 255 Left = 0 TabIndex = 22 Top = 5280 Width = 2295 End Begin VB.CommandButton cmdTransform Caption = "Transform" Default = -1 'True Height = 495 Left = 600 TabIndex = 12 Top = 5640 Width = 1095 End Begin VB.Frame Frame1 Caption = "Transformations" Height = 2535 Left = 0 TabIndex = 7 Top = 2640 Width = 2295 Begin VB.OptionButton optTransformation Caption = "Z Rotate" Height = 255 Index = 8 Left = 120 TabIndex = 19 Top = 2160 Width = 2055 End Begin VB.OptionButton optTransformation Caption = "Y Rotate" Height = 255 Index = 7 Left = 120 TabIndex = 18 Top = 1920 Width = 2055 End Begin VB.OptionButton optTransformation Caption = "X Rotate" Height = 255 Index = 6 Left = 120 TabIndex = 17 Top = 1680 Width = 2055 End Begin VB.OptionButton optTransformation Caption = "Grow, Rotate" Height = 255 Index = 5 Left = 120 TabIndex = 16 Top = 1440 Width = 2055 End Begin VB.OptionButton optTransformation Caption = "Wierd" Height = 255 Index = 4 Left = 120 TabIndex = 15 Top = 1200 Width = 2055 End Begin VB.OptionButton optTransformation Caption = "Up, Shrink/Grow" Height = 255 Index = 3 Left = 120 TabIndex = 11 Top = 960 Width = 2055 End Begin VB.OptionButton optTransformation Caption = "Up, Shrink, Twist" Height = 255 Index = 2 Left = 120 TabIndex = 10 Top = 720 Width = 2055 End Begin VB.OptionButton optTransformation Caption = "Up, Shrink" Height = 255 Index = 1 Left = 120 TabIndex = 9 Top = 480 Width = 2055 End Begin VB.OptionButton optTransformation Caption = "Up, Twist" Height = 255 Index = 0 Left = 120 TabIndex = 8 Top = 240 Value = -1 'True Width = 2055 End End Begin VB.Frame Frame2 Caption = "Curve" Height = 2535 Left = 0 TabIndex = 1 Top = 0 Width = 2295 Begin VB.OptionButton optCurve Caption = "Off Center Hexagon" Height = 255 Index = 8 Left = 120 TabIndex = 21 Top = 2160 Width = 2055 End Begin VB.OptionButton optCurve Caption = "Hexagon" Height = 255 Index = 7 Left = 120 TabIndex = 20 Top = 1920 Width = 2055 End Begin VB.OptionButton optCurve Caption = "Semicircle" Height = 255 Index = 6 Left = 120 TabIndex = 14 Top = 1680 Width = 2055 End Begin VB.OptionButton optCurve Caption = "Triangle" Height = 255 Index = 0 Left = 120 TabIndex = 13 Top = 240 Value = -1 'True Width = 2055 End Begin VB.OptionButton optCurve Caption = "Star" Height = 255 Index = 5 Left = 120 TabIndex = 6 Top = 1440 Width = 2055 End Begin VB.OptionButton optCurve Caption = "Off Center Circle" Height = 255 Index = 4 Left = 120 TabIndex = 5 Top = 1200 Width = 2055 End Begin VB.OptionButton optCurve Caption = "Circle" Height = 255 Index = 3 Left = 120 TabIndex = 4 Top = 960 Width = 2055 End Begin VB.OptionButton optCurve Caption = "Off Center Square" Height = 255 Index = 2 Left = 120 TabIndex = 3 Top = 720 Width = 2055 End Begin VB.OptionButton optCurve Caption = "Square" Height = 255 Index = 1 Left = 120 TabIndex = 2 Top = 480 Width = 2055 End End Begin VB.PictureBox picCanvas AutoRedraw = -1 'True Height = 5775 Left = 2400 ScaleHeight = 381 ScaleMode = 3 'Pixel ScaleWidth = 357 TabIndex = 0 Top = 0 Width = 5415 End Attribute VB_Name = "frmTrans" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit ' Location of viewing eye. Private EyeR As Single Private EyeTheta As Single Private EyePhi As Single Private Const dtheta = PI / 20 Private Const Dphi = PI / 20 Private Const dR = 1 ' Location of focus point. Private Const FocusX = 0# Private Const FocusY = 0# Private Const FocusZ = 0# Private Projector(1 To 4, 1 To 4) As Single Private SelectedCurve As Integer Private SelectedTransformation As Integer Private NumTrans As Integer Private trans() As Transformation Private TheSurface As Transformed3d ' Create the selected curve. Private Sub CreateCurve() Dim r As Single Dim r2 As Single Dim dtheta As Single Dim theta As Single Dim Y As Single Dim i As Integer Select Case SelectedCurve Case 0 ' Triangle. TheSurface.AddCurvePoint 2 * Cos(0), 0, 2 * Sin(0) TheSurface.AddCurvePoint 2 * Cos(4 * PI / 3), 0, 2 * Sin(4 * PI / 3) TheSurface.AddCurvePoint 2 * Cos(2 * PI / 3), 0, 2 * Sin(2 * PI / 3) TheSurface.AddCurvePoint 2 * Cos(0), 0, 2 * Sin(0) Case 1 ' Square. TheSurface.AddCurvePoint -2, 0, -2 TheSurface.AddCurvePoint -2, 0, 2 TheSurface.AddCurvePoint 2, 0, 2 TheSurface.AddCurvePoint 2, 0, -2 TheSurface.AddCurvePoint -2, 0, -2 Case 2 ' Off Center Square. TheSurface.AddCurvePoint 1, 0, 1 TheSurface.AddCurvePoint 1, 0, 3 TheSurface.AddCurvePoint 3, 0, 3 TheSurface.AddCurvePoint 3, 0, 1 TheSurface.AddCurvePoint 1, 0, 1 Case 3 ' Circle. r = 2 dtheta = PI / 8 For theta = 0 To 2 * PI - dtheta + 0.01 Step dtheta TheSurface.AddCurvePoint r * Cos(theta), 0, r * Sin(theta) Next theta TheSurface.AddCurvePoint r, 0, 0 Case 4 ' Off Center Circle. r = 1 dtheta = PI / 8 For theta = 0 To 2 * PI - dtheta + 0.01 Step dtheta TheSurface.AddCurvePoint 2 + r * Cos(theta), 0, 2 + r * Sin(theta) Next theta TheSurface.AddCurvePoint 2 + r, 0, 2 Case 5 ' Star. r = 2 r2 = 1 dtheta = 2 * PI / 5 / 2 theta = PI For i = 1 To 5 TheSurface.AddCurvePoint _ r * Cos(theta), 0, r * Sin(theta) theta = theta + dtheta TheSurface.AddCurvePoint _ r2 * Cos(theta), 0, r2 * Sin(theta) theta = theta + dtheta Next i TheSurface.AddCurvePoint _ r * Cos(PI), 0, r * Sin(PI) Case 6 ' Semicircle. r = 2 dtheta = PI / 8 For theta = 0 To PI - dtheta + 0.01 Step dtheta TheSurface.AddCurvePoint r * Cos(theta), 0, r * Sin(theta) Next theta TheSurface.AddCurvePoint -r, 0, 0 Case 7 ' Hexagon. r = 3 dtheta = 2 * PI / 6 theta = 0 For i = 1 To 7 TheSurface.AddCurvePoint _ r * Cos(theta), 0, r * Sin(theta) theta = theta + dtheta Next i Case 8 ' Off Center Hexagon. r = 2 dtheta = 2 * PI / 6 theta = 0 For i = 1 To 7 TheSurface.AddCurvePoint _ r * Cos(theta), 0, r + r * Sin(theta) theta = theta + dtheta Next i End Select End Sub ' Create the array of transformations. Private Sub CreateTransformations() Dim A(1 To 4, 1 To 4) As Single Dim B(1 To 4, 1 To 4) As Single Dim C(1 To 4, 1 To 4) As Single Dim theta As Single Dim dtheta As Single Dim r As Single Dim Y As Single Dim i As Integer Select Case SelectedTransformation Case 0 ' Up, twist. NumTrans = 9 ReDim trans(1 To NumTrans) dtheta = PI / 12 For i = 1 To NumTrans Y = i / 2 theta = i * dtheta m3Translate A, 0, Y, 0 ' Translate. m3YRotate B, theta ' Rotate. m3MatMultiply trans(i).M, A, B ' Combine. Next i Case 1 ' Up, shrink. NumTrans = 9 ReDim trans(1 To NumTrans) For i = 1 To NumTrans Y = i / 2 r = (NumTrans - i) / NumTrans m3Scale A, r, 1, r ' Scale. m3Translate B, 0, Y, 0 ' Translate. m3MatMultiply trans(i).M, A, B ' Combine. Next i Case 2 ' Up, shrink, twist. NumTrans = 9 ReDim trans(1 To NumTrans) dtheta = PI / 12 For i = 1 To NumTrans Y = i / 2 r = (NumTrans - i) / NumTrans theta = i * dtheta m3Scale A, r, 1, r ' Scale. m3Translate B, 0, Y, 0 ' Translate. m3MatMultiply C, A, B ' Combine A and B. m3YRotate A, theta ' Rotate. m3MatMultiply trans(i).M, C, A ' Combine all. Next i Case 3 ' Up, shrink/grow. NumTrans = 18 ReDim trans(1 To NumTrans) dtheta = PI / 12 For i = 1 To NumTrans Y = i / 4 theta = i * dtheta r = 1 + Sin(2 * theta) / 2 m3Scale A, r, 1, r ' Scale. m3Translate B, 0, Y, 0 ' Translate. m3MatMultiply trans(i).M, A, B ' Combine. Next i Case 4 ' Waver. ' Make the curve move upwards with ' varying rotation around the Z axis. NumTrans = 18 ReDim trans(1 To NumTrans) dtheta = PI / 12 r = PI / 2 For i = 1 To NumTrans Y = i / 4 theta = i * dtheta m3ZRotate A, r * Sin(theta) ' Rotate. m3Translate B, 0, Y, 0 ' Translate. m3MatMultiply trans(i).M, A, B ' Combine. Next i Case 5 ' Grow and rotate. ' Make the curve grow and rotate ' around the Z axis. NumTrans = 18 ReDim trans(1 To NumTrans) dtheta = PI / 12 r = PI / 2 For i = 1 To NumTrans Y = i / 4 theta = i * dtheta m3ZRotate A, r * Sin(theta) ' Rotate. m3Scale B, i / 9, i / 9, i / 9 ' Scale m3MatMultiply trans(i).M, A, B ' Combine. Next i Case 6 ' Rotate around the X axis. ' Rotate around the X axis. NumTrans = 18 ReDim trans(1 To NumTrans) dtheta = 2 * PI / NumTrans r = PI / 2 For i = 1 To NumTrans Y = i / 4 theta = i * dtheta m3XRotate trans(i).M, theta ' Rotate. Next i Case 7 ' Rotate around the Y axis. ' Rotate around the Y axis. NumTrans = 18 ReDim trans(1 To NumTrans) dtheta = 2 * PI / NumTrans r = PI / 2 For i = 1 To NumTrans Y = i / 4 theta = i * dtheta m3YRotate trans(i).M, theta ' Rotate. Next i Case 8 ' Rotate around the Z axis. ' Rotate around the Z axis. NumTrans = 18 ReDim trans(1 To NumTrans) dtheta = 2 * PI / NumTrans r = PI / 2 For i = 1 To NumTrans Y = i / 4 theta = i * dtheta m3ZRotate trans(i).M, theta ' Rotate. Next i End Select End Sub Private Sub chkHideSurfaces_Click() DrawData picCanvas picCanvas.SetFocus End Sub ' Create the surface. Private Sub cmdTransform_Click() Dim i As Integer Screen.MousePointer = vbHourglass DoEvents Set TheSurface = New Transformed3d CreateCurve CreateTransformations For i = 1 To NumTrans TheSurface.SetTransformation trans(i).M Next i TheSurface.Transform DrawData picCanvas picCanvas.SetFocus Screen.MousePointer = vbDefault End Sub ' Save the curve choice. Private Sub optCurve_Click(Index As Integer) SelectedCurve = Index End Sub ' Draw the data. Private Sub DrawData(ByVal pic As PictureBox) Dim X As Single Dim Y As Single Dim Z As Single Dim S(1 To 4, 1 To 4) As Single Dim T(1 To 4, 1 To 4) As Single Dim ST(1 To 4, 1 To 4) As Single Dim PST(1 To 4, 1 To 4) As Single ' Prevent overflow errors when drawing lines ' too far out of bounds. On Error Resume Next ' Uncull the surface. TheSurface.Culled = False ' Cull backfaces. If chkHideSurfaces.value = vbChecked Then m3SphericalToCartesian EyeR, EyeTheta, EyePhi, X, Y, Z TheSurface.Cull X, Y, Z End If ' Scale and translate so it looks OK in pixels. m3Scale S, 30, -30, 1 m3Translate T, picCanvas.ScaleWidth / 2, picCanvas.ScaleHeight / 2, 0 m3MatMultiplyFull ST, S, T m3MatMultiplyFull PST, Projector, ST ' Transform the surface and clip faces. TheSurface.ApplyFull PST ' Clip faces behind the center of projection. TheSurface.ClipEye EyeR ' Set the appropriate fill style. If chkHideSurfaces.value = vbChecked Then ' Fill to cover hidden surfaces. pic.FillStyle = vbFSSolid pic.FillColor = RGB(&HC0, &HFF, &HC0) Else ' Do not fill so all lines are visible. pic.FillStyle = vbFSTransparent End If ' Draw the surface. pic.Cls TheSurface.Draw pic, EyeR pic.Refresh End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case vbKeyLeft EyeTheta = EyeTheta - dtheta Case vbKeyRight EyeTheta = EyeTheta + dtheta Case vbKeyUp EyePhi = EyePhi - Dphi Case vbKeyDown EyePhi = EyePhi + Dphi Case Else Exit Sub End Select m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0 DrawData picCanvas End Sub Private Sub Form_KeyPress(KeyAscii As Integer) Select Case KeyAscii Case Asc("+") EyeR = EyeR + dR Case Asc("-") EyeR = EyeR - dR Case Else Exit Sub End Select m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0 DrawData picCanvas End Sub Private Sub Form_Load() ' Initialize the eye position. EyeR = 10 EyeTheta = PI * 0.2 EyePhi = PI * 0.1 ' Initialize the projection transformation. m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0 Me.Show optCurve_Click 0 End Sub ' Save the current transformation choice. Private Sub optTransformation_Click(Index As Integer) SelectedTransformation = Index End Sub